perm filename M11B.FOR[ZZZ,LCS] blob
sn#439860 filedate 1979-05-08 generic text, type T, neo UTF8
CGEN1 FUNCTION GENERATOR 1 (SEG) *** MUSIC V ***
SUBROUTINEGEN1
COMMON I(1)/P/ P(1) /GENS/GENS(1)
1 /LFUNC/LFUNC
N1=1+(IFIX(P(4))-1)*LFUNC
M1=7
102 M=M1+1
IF(P(M).LE.0)GO TO 103
V1=P(M1-2)
V2=(P(M1)-P(M1-2))/(P(M)-P(M1-1))
MA=N1+IFIX(P(M1-1))
MB=N1+IFIX(P(M))-1
DO 101 J=MA,MB
XJ=J-MA
101 GENS(J)=V1+V2*XJ
IF(IFIX(P(M)).EQ.(LFUNC-1))GO TO 103
M1=M1+2
GO TO 102
103 GENS(MB+1)=P(M1)
RETURN
END
CGEN2 FUNCTION GENERATOR 2 (SYNTH) *** MUSIC V ***
SUBROUTINEGEN2
COMMON I(1)/P/ P(1) /GENS/GENS(1)
1 /LFUNC/LFUNC
N1=1+(IFIX(P(4))-1)*LFUNC
N2=N1+LFUNC-1
DO 101 K1=N1,N2
101 GENS(K1)=0.0
FAC=6.283185/(FLOAT(LFUNC)-1.0)
NMAX=I(1)
N3=5+INT(ABS(P(NMAX)))-1
IF(N3-5.LT.0)GO TO 104
DO 103 J=5,N3
FACK=FAC*FLOAT(J-4)
DO 102 K=N1,N2
102 GENS(K)=GENS(K)+SIN(FACK*FLOAT(K-N1))*P(J)
103 CONTINUE
104 N4=N3+1
N5=I(1)-1
IF(N5-N4.LT.0)GO TO 114
DO 107 J1=N4,N5
FACK=FAC*FLOAT(J1-N4)
DO 106 K1=N1,N2
106 GENS(K1)=GENS(K1)+COS(FACK*FLOAT(K1-N1))*P(J1)
107 CONTINUE
114 IF(P(NMAX).LE.0)GO TO 112
FMAX=0.0
DO 110 K2=N1,N2
A=ABS(GENS(K2))
110 IF(FMAX.LT.A)FMAX=A
113 DO 111 K3=N1,N2
111 GENS(K3)=GENS(K3)/FMAX
RETURN
112 FMAX=.99999
GO TO 113
END
SUBROUTINE SAMOUT(IDSK,N)
COMMON I(1) /ROUT/ROUT(1) /FINOUT/JPEAK,IPEAK,NBUF
1 /CONV/ICONV,INIOUT,JFLNM
COMMON /DEVS/ID1,ID21,JTYPE,ID23,KOUT
DATA TEST/'TEST'/
DIMENSION IDBUF(2048),JDBUF(512),NN(512),LDBUF(512)
EQUIVALENCE (IDBUF,JDBUF),(LDBUF,IDBUF(513))
C*** IDBUF WILL STORE PACKED SAMPLES. ****
CPDP10 IF(ICONV.EQ.0)GO TO 2
CPDP10 CALL SAMO2(IDSK,N)
C THIS IS FOR INTERACTIVE USE.
CPDP10 RETURN
CPDP10 2 IF(INIOUT.EQ.0)GO TO 99
C NOW OPEN PROPER OUTPUT FILE
INIOUT=0
IDSK=0
CALL DISKO(ID23,TEST,2)
C 2=UNFORMATTED OUTPUT
C OUTPUT IS ALWAYS NAMED 'TEST.DAT' FOR NOW.
99 J=IDSK+1
M1=1
M2=0
IDSK=IDSK+N
C COUNTS SAMPLES TO DATE
DO 1 K=J,IDSK
IS=ROUT(M1+M2)
IA=IABS(IS)
IF(IA.GT.IPEAK)IPEAK=IA
IDBUF(K)=IS
1 M2=M2+1
IF(IDSK.LT.NBUF)RETURN
C NBUF=512,MONO =1024,STEREO
11 WRITE(ID23)JDBUF
IF(NBUF.NE.512)WRITE(ID23),LDBUF
C ABOVE FOR STEREO
10 J=IDSK-NBUF
IF(J.LT.1)GO TO 4
DO 5 K=1,J
5 IDBUF(K)=IDBUF(NBUF+K)
4 IDSK=J
RETURN
END
CERRO1 GENERAL ERROR ROUTINE *** MUSIC V ***
SUBROUTINE ERROR(I)
COMMON /DEVS/ID1,ID21,JTYPE,ID23,KOUT
WRITE(JTYPE,100),I
100 FORMAT (' ERROR OF TYPE',I5/)
RETURN
END